home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Marlais / Marlais 0.5.9-portable sources / env.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  20.6 KB  |  878 lines  |  [TEXT/ttxt]
  1. /*
  2.  
  3.    env.c
  4.  
  5.    This software is free software; you can redistribute it and/or
  6.    modify it under the terms of the GNU Library General Public
  7.    License as published by the Free Software Foundation; either
  8.    version 2 of the License, or (at your option) any later version.
  9.  
  10.    This software is distributed in the hope that it will be useful,
  11.    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13.    Library General Public License for more details.
  14.  
  15.    You should have received a copy of the GNU Library General Public
  16.    License along with this software; if not, write to the Free
  17.    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.    Original copyright notice follows:
  20.  
  21.    Copyright, 1993, Brent Benson.  All Rights Reserved.
  22.    0.4 & 0.5 Revisions Copyright 1994, Joseph N. Wilson.  All Rights Reserved.
  23.  
  24.    Permission to use, copy, and modify this software and its
  25.    documentation is hereby granted only under the following terms and
  26.    conditions.  Both the above copyright notice and this permission
  27.    notice must appear in all copies of the software, derivative works
  28.    or modified version, and both notices must appear in supporting
  29.    documentation.  Users of this software agree to the terms and
  30.    conditions set forth in this notice.
  31.  
  32.  */
  33.  
  34. #include <string.h>
  35.  
  36. #include "env.h"
  37.  
  38. #include "alloc.h"
  39. #include "bytestring.h"
  40. #include "class.h"
  41. #include "error.h"
  42. #include "eval.h"
  43. #include "keyword.h"
  44. #include "list.h"
  45. #include "prim.h"
  46. #include "print.h"
  47. #include "table.h"
  48.  
  49. extern Object dylan_symbol;
  50. extern Object dylan_user_symbol;
  51. extern Object empty_string;
  52.  
  53. int trace_bindings = 0;
  54.  
  55. /* the environment */
  56. struct frame *the_env;
  57.  
  58. struct module_binding *the_current_module;
  59.  
  60. struct modules {
  61.     int size;
  62.     struct module_binding **bindings;
  63. };
  64.  
  65. struct modules modules =
  66. {0, NULL};
  67.  
  68. /* the top level environment */
  69. #define BIND_ALLOC_CHUNK 4
  70.  
  71. /* If TOP_LEVEL_SIZE is not a power of two, see change required below */
  72. #define TOP_LEVEL_SIZE 1024
  73. /* struct binding *top_level_env[TOP_LEVEL_SIZE]; */
  74.  
  75. /* local function prototypes */
  76. struct binding *symbol_binding (Object sym);
  77. static Object concat_prefix (char *prefix_string, Object sym);
  78. static void fill_imports_table_from_property_set (Object imports_table,
  79.                           Object imports_set,
  80.                           Object renames_table);
  81.  
  82. /* function definitions */
  83.  
  84. static struct frame *
  85. initialize_namespace (Object owner)
  86. {
  87.     struct frame *frame;
  88.  
  89.     frame = (struct frame *) allocate_frame ();
  90.     frame->size = TOP_LEVEL_SIZE;
  91.     frame->owner = owner;
  92.     frame->bindings =
  93.     (struct binding **) checking_malloc (TOP_LEVEL_SIZE * sizeof (struct binding));
  94.  
  95.     frame->next = NULL;
  96.     frame->top_level_env = frame->bindings;
  97.     return frame;
  98. }
  99.  
  100. void
  101. add_top_level_binding (Object sym, Object val, int constant)
  102. {
  103.     struct binding *binding, *old_binding;
  104.     int i;
  105.     unsigned h;
  106.     char *str;
  107.  
  108.     binding = (struct binding *) allocate_binding ();
  109.     if (PAIRP (sym)) {
  110.     binding->sym = CAR (sym);
  111.     binding->type = eval (SECOND (sym));
  112.     } else {
  113.     binding->sym = sym;
  114.     binding->type = object_class;
  115.     }
  116.  
  117.     binding->props &= !IMPORTED_BINDING;
  118.  
  119.     /* Just for now */
  120.     binding->props |= EXPORTED_BINDING;
  121.     /* */
  122.  
  123.     if (constant) {
  124.     binding->props |= CONSTANT_BINDING;
  125.     }
  126.     old_binding = symbol_binding_top_level (binding->sym);
  127.     if (old_binding != NULL) {
  128.     warning ("Symbol already defined. Previous value",
  129.          sym,
  130.          *(old_binding->val),
  131.          NULL);
  132.     }
  133.     binding->val = (Object *) allocate_object (sizeof (Object *));
  134.  
  135.     *(binding->val) = val;
  136.  
  137.     i = h = 0;
  138.     str = SYMBOLNAME (binding->sym);
  139.     while (str[i]) {
  140.     h += str[i++];
  141.     }
  142. /*
  143.    h = h % TOP_LEVEL_SIZE;
  144.  */
  145.  
  146.     /* Works only if TOP_LEVEL_SIZE is a power of 2 */
  147.     h &= (TOP_LEVEL_SIZE - 1);
  148.  
  149.     binding->next = the_env->top_level_env[h];
  150.     the_env->top_level_env[h] = binding;
  151.  
  152.     if (trace_bindings) {
  153.     print_obj (sym);
  154.     }
  155. }
  156.  
  157. void
  158. push_scope (Object owner)
  159. {
  160.     struct frame *frame;
  161.  
  162.     /* push a new frame */
  163.     frame = (struct frame *) allocate_frame ();
  164.     frame->owner = owner;
  165.     frame->size = 0;
  166.     frame->bindings = NULL;
  167.     frame->next = the_env;
  168.     frame->top_level_env = the_env->top_level_env;
  169.     the_env = frame;
  170.     eval_stack->frame = frame;
  171. }
  172.  
  173. void
  174. pop_scope (void)
  175. {
  176.     the_env = the_env->next;
  177. }
  178.  
  179. void
  180. add_bindings (Object syms, Object vals, int constant)
  181. {
  182.     struct frame *frame;
  183.     struct binding **bindings;
  184.     struct binding *binding;
  185.     int num_bindings, i;
  186.     Object sym_list;
  187.  
  188.     sym_list = syms;
  189.     num_bindings = 0;
  190.     while (!NULLP (sym_list)) {
  191.     num_bindings++;
  192.     sym_list = CDR (sym_list);
  193.     }
  194.  
  195.     frame = the_env;
  196.     frame->bindings = (struct binding **)
  197.     checking_realloc (frame->bindings,
  198.           (frame->size + num_bindings) * sizeof (struct binding *));
  199.  
  200.     for (i = 0; i < num_bindings; ++i) {
  201.     if ((!syms) || (!vals)) {
  202.         error ("mismatched number of symbols and values", NULL);
  203.     }
  204.     binding = (struct binding *) allocate_binding ();
  205.     binding->sym = CAR (syms);
  206. /* ??? */
  207.     binding->type = object_class;
  208.     binding->val = (Object *) allocate_object (sizeof (Object *));
  209.  
  210.     *(binding->val) = CAR (vals);
  211.  
  212.     binding->props &= !IMPORTED_BINDING;
  213.     /* Just for now */
  214.     binding->props |= EXPORTED_BINDING;
  215.     if (constant) {
  216.         binding->props |= CONSTANT_BINDING;
  217.     }
  218.     frame->bindings[i + frame->size] = binding;
  219.  
  220.     syms = CDR (syms);
  221.     vals = CDR (vals);
  222.     }
  223.     frame->size += num_bindings;
  224. }
  225.  
  226. void
  227. add_binding (Object sym, Object val, int constant)
  228. {
  229.     struct frame *frame;
  230.     struct binding *binding;
  231.  
  232.     binding = (struct binding *) allocate_binding ();
  233.     if (PAIRP (sym)) {
  234.     binding->sym = CAR (sym);
  235.     binding->type = eval (SECOND (sym));
  236.     } else {
  237.     binding->sym = sym;
  238.     binding->type = object_class;
  239.     }
  240.     binding->val = (Object *) allocate_object (sizeof (Object *));
  241.  
  242.     *(binding->val) = val;
  243.     binding->props &= !IMPORTED_BINDING;
  244.     /* Just for now */
  245.     binding->props |= EXPORTED_BINDING;
  246.     if (constant) {
  247.     binding->props |= CONSTANT_BINDING;
  248.     }
  249.     frame = the_env;
  250.  
  251.     if ((frame->size % BIND_ALLOC_CHUNK) == 0) {
  252.     frame->bindings = (struct binding **)
  253.         checking_realloc (frame->bindings,
  254.           (frame->size + BIND_ALLOC_CHUNK) * sizeof (struct binding *));
  255.     }
  256.     frame->bindings[frame->size] = binding;
  257.     frame->size++;
  258. }
  259.  
  260. /* Change the binding of the symbol in top-most frame.
  261.    Return 1 on success.  If there is no such binding,
  262.    return 0.
  263.  
  264.    This isn't correct.  It uses symbol_binding() which
  265.    checks *all* bindings of the symbol, not just the
  266.    top level.
  267.  */
  268. int
  269. change_binding (Object sym, Object val)
  270. {
  271.     struct binding *binding;
  272.  
  273.     binding = symbol_binding (sym);
  274.     if (!binding) {
  275.     return (0);
  276.     } else {
  277. /*
  278.    if ( ! instance (val, binding->type)) {
  279.  */
  280.     *(binding->val) = val;
  281.     return 1;
  282. /*
  283.    } else {
  284.    error("attempt to assign binding of wrong type", sym, val,NULL);
  285.    return 0;
  286.    }
  287.  */
  288.     }
  289. }
  290.  
  291. Object
  292. symbol_value (Object sym)
  293. {
  294.     struct binding *binding;
  295.  
  296.     binding = symbol_binding (sym);
  297.     if (!binding) {
  298.     return (NULL);
  299.     }
  300.     return (*(binding->val));
  301. }
  302.  
  303. void
  304. modify_value (Object sym, Object new_val)
  305. {
  306.     struct binding *binding;
  307.  
  308.     binding = symbol_binding (sym);
  309.     if (!binding) {
  310.     error ("attempt to modify value of unbound symbol", sym, NULL);
  311.     } else if (IS_CONSTANT_BINDING (binding)) {
  312.     error ("attempt to modify value of a constant", sym, NULL);
  313.     } else if (instance (new_val, binding->type)) {
  314.     *(binding->val) = new_val;
  315.     } else {
  316.     error ("attempt to assign variable an incompatible object",
  317.            sym, new_val, NULL);
  318.     }
  319. }
  320.  
  321. struct frame *
  322. current_env (void)
  323. {
  324.     return (the_env);
  325. }
  326.  
  327. /* primitives */
  328.  
  329. Object user_current_module (void);
  330. Object user_set_module (Object args);
  331.  
  332. #if 0
  333. static Object reset_module (Object args);
  334.  
  335. #endif
  336.  
  337. static struct primitive env_prims[] =
  338. {
  339.     {"current-module", prim_0, user_current_module},
  340.     {"set-module", prim_0_rest, user_set_module},
  341. #if 0
  342.     {"reset-module", prim_0_rest, reset_module},
  343. #endif
  344. };
  345.  
  346. /* functions */
  347.  
  348. void
  349. init_env_prims (void)
  350. {
  351.     int num;
  352.  
  353.     num = sizeof (env_prims) / sizeof (struct primitive);
  354.  
  355.     init_prims (num, env_prims);
  356. }
  357.  
  358. /* local functions */
  359.  
  360. /* made symbol_binding non local to be able to fix <object> binding */
  361. struct binding *
  362. symbol_binding (Object sym)
  363. {
  364.     struct frame *frame;
  365.     struct binding *binding;
  366.     int i;
  367.  
  368.     frame = the_env;
  369.     while (frame->bindings != frame->top_level_env) {
  370.     for (i = 0; i < frame->size; ++i) {
  371.         binding = frame->bindings[i];
  372.         if (binding->sym == sym) {
  373.         return (binding);
  374.         }
  375.     }
  376.     frame = frame->next;
  377.     if (!frame)
  378.         break;        /* <pcb> I/'ve observed this to be nil in a special case. */
  379.     }
  380.     /* can't find binding in frames, look at top_level */
  381.     return (symbol_binding_top_level (sym));
  382. }
  383.  
  384. struct binding *
  385. symbol_binding_top_level (Object sym)
  386. {
  387.     struct binding *binding;
  388.     int h, i;
  389.     char *str;
  390.  
  391.     i = h = 0;
  392.     str = SYMBOLNAME (sym);
  393.     while (str[i]) {
  394.     h += str[i++];
  395.     }
  396.     h = h % TOP_LEVEL_SIZE;
  397.  
  398.     binding = the_env->top_level_env[h];
  399.     while (binding) {
  400.     if (binding->sym == sym) {
  401.         return (binding);
  402.     }
  403.     binding = binding->next;
  404.     }
  405.     return (NULL);
  406. }
  407.  
  408. /* Unwind the stack of frames until we reach a frame
  409.    with exit_sym as its only binding.  Perform unwind-protect
  410.    cleanups when we find them. */
  411. void
  412. unwind_to_exit (Object exit_sym)
  413. {
  414.     struct frame *frame;
  415.     Object body, ret;
  416.     int i;
  417.  
  418.     frame = the_env;
  419.     while (frame) {
  420.     if (frame->bindings) {
  421.         if (frame->bindings[0]->sym == exit_sym) {
  422.         the_env = frame->next;
  423.         return;
  424.         }
  425.         if (frame->bindings[0]->sym == unwind_symbol) {
  426.         body = UNWINDBODY (*(frame->bindings[0]->val));
  427.         while (!NULLP (body)) {
  428.             ret = eval (CAR (body));
  429.             body = CDR (body);
  430.         }
  431.         }
  432.     }
  433.     frame = frame->next;
  434.     }
  435.     error ("unwound to end of stack and can't find exit procedure binding", exit_sym, NULL);
  436.  
  437. }
  438.  
  439. struct module_binding *
  440. new_module (Object module_name)
  441. {
  442.     struct module_binding *this_module;
  443.  
  444.     this_module = (struct module_binding *) allocate_module_binding ();
  445.     this_module->sym = module_name;
  446.     this_module->namespace = initialize_namespace (module_name);
  447.     this_module->exported_bindings = make_table (DEFAULT_TABLE_SIZE);
  448.  
  449.  
  450.     modules.bindings = (struct module_binding **)
  451.     checking_realloc (modules.bindings,
  452.               (modules.size + BIND_ALLOC_CHUNK) *
  453.               sizeof (struct module_binding *));
  454.  
  455.     modules.bindings[modules.size] = this_module;
  456.     modules.size++;
  457.  
  458.     return this_module;
  459. }
  460.  
  461.  
  462. struct module_binding *
  463. module_binding (Object module_name)
  464. {
  465.     struct module_binding *binding;
  466.     int i;
  467.  
  468.     for (i = 0; i < modules.size; ++i) {
  469.     binding = modules.bindings[i];
  470.     if (binding->sym == module_name) {
  471.         return (binding);
  472.     }
  473.     }
  474.     error ("Unable to find binding for module", module_name, NULL);
  475.  
  476. }
  477.  
  478. Object
  479. user_set_module (Object args)
  480. {
  481.     Object module_name;
  482.  
  483.     if (list_length (args) != 1) {
  484.     error ("set-module: requires a single argument", NULL);
  485.     } else {
  486.     module_name = CAR (args);
  487.     }
  488.     if (KEYWORDP (module_name)) {
  489.     return
  490.         symbol_to_keyword (set_module
  491.                    (module_binding
  492.                 (keyword_to_symbol (module_name)))
  493.                    ->sym);
  494.     } else {
  495.     error ("set-module: argument should be a symbol", module_name, NULL);
  496.     }
  497. }
  498.  
  499. struct module_binding *
  500. set_module (struct module_binding *new_module)
  501. {
  502.     struct module_binding *old_module = current_module ();
  503.  
  504.     the_env = new_module->namespace;
  505.     if (eval_stack && eval_stack->next == 0) {
  506.     eval_stack = 0;
  507.     }
  508.     push_eval_stack (new_module->sym);
  509.     eval_stack->frame = the_env;
  510.  
  511.     the_current_module = new_module;
  512.     return old_module;
  513. }
  514.  
  515. #if 0
  516. /* This is definitely an idea whose time has not come. */
  517. Object
  518. reset_module (Object args)
  519. {
  520.     struct module_binding *binding;
  521.     Object module_name;
  522.     int i;
  523.  
  524.  
  525.     if (list_length (args) != 1 || !KEYWORDP (CAR (args))) {
  526.     error ("reset-module: Requires exactly one symbol argument", NULL);
  527.     }
  528.     module_name = keyword_to_symbol (CAR (args));
  529.     if (module_name == dylan_symbol || module_name == dylan_user_symbol) {
  530.     error ("reset-module: Reset not permitted on this module",
  531.            module_name,
  532.            NULL);
  533.     }
  534.     for (i = 0; i < modules.size; ++i) {
  535.     binding = modules.bindings[i];
  536.     if (binding->sym == module_name) {
  537.         binding->namespace = initialize_namespace (module_name);
  538.         return (unspecified_object);
  539.     } else {
  540.         warning ("Saw module", binding->sym, NULL);
  541.     }
  542.     }
  543.     error ("reset-module: Attempt to reset nonexistent module",
  544.        module_name,
  545.        NULL);
  546. }
  547. #endif
  548.  
  549. static void
  550. import_top_level_binding (struct binding *import_binding,
  551.               struct binding **bindings,
  552.               int all_imports)
  553. {
  554.     struct binding *binding, *old_binding;
  555.     unsigned i;
  556.     unsigned h;
  557.     char *str;
  558.  
  559.     binding = (struct binding *) allocate_binding ();
  560.  
  561.     binding->type = import_binding->type;
  562. /*    binding->props |= import_binding->props & CONSTANT_BINDING; */
  563.     binding->props |= import_binding->props;
  564.  
  565.  
  566.     /* Share storage with old binding */
  567.     binding->val = import_binding->val;
  568.     binding->next = *bindings;
  569.     *bindings = binding;
  570. }
  571.  
  572. Object
  573. use_module (Object module_name,
  574.         Object imports,
  575.         Object exclusions,
  576.         Object prefix,
  577.         Object renames,
  578.         Object exports)
  579. {
  580.     struct frame *frame;
  581.     struct binding *binding;
  582.     struct binding *bindings = NULL;
  583.     struct binding *old_binding;
  584.     struct module_binding *import_module;
  585.     unsigned i;
  586.     int all_imports;
  587.     char *prefix_string;
  588.     Object imports_table, exclusions_table, renames_table, exports_table;
  589.     Object new_sym;
  590.  
  591.     /*
  592.      * Store property sets in tables for quick reference.
  593.      */
  594.     renames_table = make_table (DEFAULT_TABLE_SIZE);
  595.     if (imports != all_symbol) {
  596.     imports_table = make_table (DEFAULT_TABLE_SIZE);
  597.     fill_imports_table_from_property_set (imports_table,
  598.                           imports,
  599.                           renames_table);
  600.     } else {
  601.     all_imports = 1;
  602.     }
  603.  
  604.     exclusions_table = make_table (DEFAULT_TABLE_SIZE);
  605.     fill_table_from_property_set (exclusions_table, exclusions);
  606.  
  607.     fill_table_from_property_set (renames_table, renames);
  608.     if (exports != all_symbol) {
  609.     exports_table = make_table (DEFAULT_TABLE_SIZE);
  610.     fill_table_from_property_set (exports_table, exports);
  611.     }
  612.     if (prefix == empty_string) {
  613.     prefix_string = 0;
  614.     } else {
  615.     prefix_string = BYTESTRVAL (prefix);
  616.     }
  617.  
  618.     /*
  619.      * Now inspect all the bindings from the imported module.
  620.      * If imports == all, this is probably a good idea.  On the other
  621.      * hand, if imports != all, we might want to just look at the
  622.      * symbols to be imported.
  623.      */
  624.     if (SYMBOLP (module_name)) {
  625.  
  626.     import_module = module_binding (module_name);
  627.     frame = import_module->namespace;
  628.     /* Look at each has location */
  629.     for (i = 0; i < TOP_LEVEL_SIZE; i++) {
  630.         binding = frame->top_level_env[i];
  631.  
  632.         /* Look at each bucket in a hash location */
  633.         while (binding) {
  634.         if (IS_EXPORTED_BINDING (binding) &&
  635.             (import_module->exported_bindings == all_symbol ||
  636.              table_element (import_module->exported_bindings,
  637.                     binding->sym,
  638.                     false_object) != false_object) &&
  639.             (all_imports ||
  640.              (table_element (imports_table, binding, false_object)
  641.               != false_object))) {
  642.  
  643.             /*
  644.              * This binding is importable.  Go for it.
  645.              */
  646.             import_top_level_binding (binding,
  647.                           &bindings,
  648.                           all_imports);
  649.             /*
  650.              * See what the bindings name needs to be.
  651.              */
  652.             if ((new_sym = table_element (renames_table,
  653.                           binding->sym,
  654.                           false_object))
  655.             == false_object) {
  656.             new_sym = prefix_string ? concat_prefix (prefix_string,
  657.                                    binding->sym)
  658.                 : binding->sym;
  659.             }
  660.             /*
  661.              * See if we've already got this binding.
  662.              * Two possibilities here:
  663.              *  1. We've got a conflict with a symbol in our current
  664.              *     module (Squawk but don't die).
  665.              *  2. We're importing the same symbol again (Say nothing).
  666.              */
  667.             old_binding = symbol_binding_top_level (new_sym);
  668.             if (old_binding != NULL) {
  669.             if (old_binding->val != bindings->val) {
  670.                 warning ("Ignoring import that conflicts with defined symbol",
  671.                      binding->sym,
  672.                      NULL);
  673.             }
  674.             bindings = bindings->next;
  675.             binding = binding->next;
  676.             continue;
  677.             }
  678.             /*
  679.              * Associate the new binding with this sym and determine
  680.              * if it is exportable.
  681.              */
  682.             bindings->sym = new_sym;
  683.             if (exports != all_symbol &&
  684.             (table_element (exports_table,
  685.                     new_sym,
  686.                     false_object)
  687.              == false_object)) {
  688.             /* This binding can't be exported */
  689.             bindings->props &= !EXPORTED_BINDING;
  690.             bindings->props |= IMPORTED_BINDING;
  691.             } else {
  692.             bindings->props |= EXPORTED_BINDING;
  693.             bindings->props |= IMPORTED_BINDING;
  694.             }
  695.         }
  696.         binding = binding->next;
  697.         }
  698.  
  699.         /* Now put the bindings in place. */
  700.         while (bindings != NULL) {
  701.         int h, i;
  702.         char *str;
  703.  
  704.         binding = bindings;
  705.         bindings = bindings->next;
  706.  
  707.         i = h = 0;
  708.         str = SYMBOLNAME (binding->sym);
  709.         while (str[i]) {
  710.             h += str[i++];
  711.         }
  712.         /*
  713.            h = h % TOP_LEVEL_SIZE;
  714.          */
  715.  
  716.         /* Works only if TOP_LEVEL_SIZE is a power of 2 */
  717.         h &= (TOP_LEVEL_SIZE - 1);
  718.  
  719.         binding->next = the_env->top_level_env[h];
  720.         the_env->top_level_env[h] = binding;
  721.         }
  722.     }
  723.     } else {
  724.     error ("use: argument should be a symbol", module_name, NULL);
  725.     }
  726.     return unspecified_object;
  727. }
  728.  
  729. Object
  730. user_current_module ()
  731. {
  732.     return symbol_to_keyword (current_module ()->sym);
  733. }
  734.  
  735. struct module_binding *
  736. current_module ()
  737. {
  738.     return the_current_module;
  739. }
  740.  
  741. Object
  742. print_env (struct frame *env)
  743. {
  744.     struct frame *frame;
  745.     int i;
  746.  
  747.     for (i = 0, frame = env; frame != NULL; frame = frame->next, i++) {
  748.     fprintf (stderr, "#%d ", i);
  749.     print_object (stderr, frame->owner, 1);
  750.     fprintf (stderr, "\n");
  751.     }
  752.     return unspecified_object;
  753. }
  754.  
  755. Object
  756. show_bindings (Object args)
  757. {
  758.     struct frame *frame;
  759.     int i;
  760.     int slot;
  761.     struct binding **bindings, *binding;
  762.     int frame_number;
  763.  
  764.     if (list_length (args) != 1 || !INTEGERP (CAR (args))) {
  765.     error ("show_bindings: requires a single <integer> argument", NULL);
  766.     }
  767.     frame_number = INTVAL (CAR (args));
  768.  
  769.     for (frame = the_env, i = frame_number;
  770.      i > 0 && frame != NULL;
  771.      frame = frame->next, i--) ;
  772.     if (i != 0) {
  773.     fprintf (stderr, "Frame number %d does not exist\n",
  774.          frame_number);
  775.     } else {
  776.     fprintf (stderr, "** Bindings for frame %d [",
  777.          frame_number);
  778.     print_object (stderr, frame->owner, 1);
  779.     fprintf (stderr, "]\n");
  780.     /*
  781.      * Print the bindings in all the frame slots.
  782.      */
  783.     for (bindings = frame->bindings, slot = 0;
  784.          slot < frame->size;
  785.          slot++) {
  786.         /*
  787.          * Print the bindings in one slot
  788.          */
  789.         for (binding = frame->bindings[slot];
  790.          binding != NULL;
  791.          binding = binding->next) {
  792.         fprintf (stderr, "   ");
  793.         print_object (stderr, binding->sym, 1);
  794.         if (binding->type != object_class) {
  795.             fprintf (stderr, " :: ");
  796.             print_object (stderr, binding->type, 1);
  797.         }
  798.         fprintf (stderr, " = ");
  799.         print_object (stderr, *(binding->val), 1);
  800.         fprintf (stderr, "\n");
  801.         }
  802.     }
  803.  
  804.     }
  805.     return unspecified_object;
  806. }
  807.  
  808. Object
  809. make_environment (struct frame *env)
  810. {
  811.     Object obj;
  812.  
  813.     obj = allocate_object (sizeof (struct environment));
  814.  
  815.     ENVIRONMENTTYPE (obj) = Environment;
  816.     ENVIRONMENT (obj) = env;
  817.     return obj;
  818. }
  819.  
  820. static Object
  821. concat_prefix (char *prefix_string, Object sym)
  822. {
  823.     char *new_str, *old_str = SYMBOLNAME (sym);
  824.     int prefix_len = strlen (prefix_string);
  825.  
  826.     new_str = (char *) allocate_string (prefix_len + strlen (old_str) + 1);
  827.     strcpy (new_str, prefix_string);
  828.     strcpy (new_str + prefix_len, old_str);
  829.     return make_symbol (new_str);
  830. }
  831.  
  832. /*
  833.  * Stores entry for each property in the_set in the_table.  If
  834.  * property is an atom, the key and value are both the atom.
  835.  * If property is a pair, the key is the CAR and the value is the CDR.
  836.  */
  837. void
  838. fill_table_from_property_set (Object the_table, Object the_set)
  839. {
  840.     Object the_element;
  841.  
  842.     while (!EMPTYLISTP (the_set)) {
  843.     the_element = CAR (the_set);
  844.     if (PAIRP (the_element)) {
  845.         table_element_setter (the_table,
  846.                   CAR (the_element),
  847.                   CDR (the_element));
  848.     } else {
  849.         table_element_setter (the_table, the_element, the_element);
  850.     }
  851.     the_set = CDR (the_set);
  852.     }
  853. }
  854.  
  855. /*
  856.  * Like fill_table_from..., but stores variable renamings in renames_table.
  857.  */
  858. static void
  859. fill_imports_table_from_property_set (Object imports_table,
  860.                       Object imports_set,
  861.                       Object renames_table)
  862. {
  863.     Object the_element;
  864.  
  865.     while (!EMPTYLISTP (imports_set)) {
  866.     the_element = CAR (imports_set);
  867.     if (PAIRP (the_element)) {
  868.         table_element_setter (imports_table, the_element, the_element);
  869.         table_element_setter (renames_table,
  870.                   CAR (the_element),
  871.                   CDR (the_element));
  872.     } else {
  873.         table_element_setter (imports_table, the_element, the_element);
  874.     }
  875.     imports_set = CDR (imports_set);
  876.     }
  877. }
  878.